Pascal Super Library/Pascal Super Library (CW International)(1997).bin/LIBRARY/TIPS/FORMLINE.PAS

Pascal/Delphi Source File | 1991-10-09 | 12KB | 464 lines

{************************************************}
{                                                }
{   Turbo Pascal for Windows                     }
{   Formatted Input Edit Control Unit            }
{   Copyright (c) 1991 by Borland International  }
{                                                }
{   by Jason Sprenger and John Wong              }
{************************************************}

unit Formline;

interface

uses
  WinTypes, WinProcs,
  WObjects, Strings;

const
  flPicOverflow = -2;
  flError = -1;
  flCharOk = 0;
  flFormatOk = 1;
  FormatSet = ['#', '?', '&', '@', '!', ';', '{', '}', '[', ']', '*'];

type
  PFormEdit = ^TFormEdit;
  TFormEdit = object(TEdit)
    Picture: PChar;
    constructor Init(AParent: PWindowsObject; AnId: Integer;
      ATitle: PChar; X, Y, W, H, ATextLen: Integer; APicture: PChar);
    constructor InitResource(AParent: PWindowsObject;
      ResourceID, ATextLen: Word; APicture: PChar);
    destructor Done; virtual;
    procedure ChangePicture(APicture: PChar);
    procedure WMSetFocus(var Message: TMessage);
      virtual wm_First + wm_SetFocus;
    procedure Store(var S: TStream); virtual;
    procedure Load(var S: TStream); virtual;
    function CanClose: Boolean; virtual;
    procedure WMChar(var Message: TMessage);
      virtual wm_First + wm_Char;
    function CheckPicture(var Info: PChar; Pic: PChar;
      var CPos, Resolved: Integer): Integer;
  end;

implementation

constructor TFormEdit.Init;
begin
  TEdit.Init(AParent, AnID, ATitle, X, Y, W, H, ATextLen, false);
  GetMem(Picture, 255);
  StrCopy(Picture, APicture);
end;

constructor TFormEdit.InitResource(AParent: PWindowsObject;
  ResourceID, ATextLen: Word; APicture: PChar);
begin
  TEdit.InitResource(AParent, ResourceID, ATextLen);
  Picture := StrNew(APicture);
end;

destructor TFormEdit.Done;
begin
  StrDispose(Picture);
end;

procedure TFormEdit.ChangePicture(APicture: PChar);
begin
  StrDispose(Picture);
  Picture := StrNew(APicture);
end;

procedure TFormEdit.WMSetFocus(var Message: TMessage);
var
  Text: PChar;
  CPos, Resolved: Integer;
begin
  DefWndProc(Message);
  GetMem(Text, 255);
  GetText(Text, 255);
  if StrLen(Text) = 0 then
  begin
    CPos := 0;
    Resolved := 0;
    CheckPicture(Text, Picture, CPos, Resolved);
    if StrLen(Text) > 0 then
    begin
      SetText(Text);
      CPos := StrLen(Text);
      SetSelection(CPos + 1, CPos + 1);
    end;
  end;
end;

procedure TFormEdit.Store(var S: TStream);
begin
  TEdit.Store(S);
  S.StrWrite(Picture);
end;

procedure TFormEdit.Load(var S: TStream);
begin
  TEdit.Load(S);
  Picture := S.StrRead;
end;

function TFormEdit.CanClose: Boolean;
var
  FirstText, NextText: PChar;
  CPos, Dummy: Integer;
  Result: Integer;
  Resolved: Integer;
begin
  GetMem(FirstText, 255);
  GetText(FirstText, 255);
  if StrLen(FirstText) > 0 then  { don't perform validation if field is empty }
  begin
    GetMem(NextText, 255);
    StrCopy(NextText, FirstText);
    GetSelection(CPos, Dummy);
    Result := CheckPicture(NextText, Picture, CPos, Resolved);
    if Result = flFormatOk then
    begin
      CanClose := True;
      if StrComp(FirstText, NextText) <> 0 then
      begin
        SetText(NextText);
        SetSelection(CPos + 1, CPos + 1);
      end
    end
    else
    begin
      CanClose := False;
      SetText(FirstText);
      SetSelection(CPos, CPos);
      MessageBeep(0);
      SetFocus(HWindow);
    end;
    FreeMem(NextText, 255);
  end;
  FreeMem(FirstText, 255);
end;

function TFormEdit.Checkpicture(var Info: PChar; Pic: PChar;
  var CPos, Resolved: Integer): Integer;
var
  InfoIndex, PicIndex: Integer;
  Committed, MayCommit: Boolean;
  Result: Boolean;

  function VariableResolution: Boolean;
  var
    Result: Boolean;
  begin
    Result := true;
    if (PicIndex < StrLen(Pic)) and (InfoIndex < StrLen(Info)) then
    begin
      case Pic[PicIndex] of
        '#':
        begin
          Result := Info[InfoIndex] in ['0'..'9'];
          if Result then
          begin
            inc(PicIndex);
            inc(InfoIndex);
            inc(Resolved);
          end;
        end;

        '?':
        begin
          Result := Info[InfoIndex] in ['a'..'z','A'..'Z'];
          if Result then
          begin
            inc(PicIndex);
            inc(InfoIndex);
            inc(Resolved);
          end;
        end;

        '&':
        begin
          Result := Info[InfoIndex] in ['a'..'z','A'..'Z'];
          if Result then
          begin
            Info[InfoIndex]:=UpCase(Info[InfoIndex]);
            inc(PicIndex);
            inc(InfoIndex);
            inc(Resolved);
          end;
        end;

        '@':
        begin
          Result := true;
          inc(PicIndex);
          inc(InfoIndex);
          inc(Resolved);
        end;

        '!':
        begin
          Result := true;
          Info[InfoIndex] := UpCase(Info[InfoIndex]);
          inc(PicIndex);
          inc(InfoIndex);
          inc(Resolved);
        end;

        ';':
        begin
          inc(PicIndex);
          Result := Info[InfoIndex] = Pic[PicIndex];
          if Result then
          begin
            inc(PicIndex);
            inc(InfoIndex);
            inc(Resolved);
          end;
        end

        else
        begin
          Result := Info[InfoIndex] = Pic[PicIndex];
          if Result then
          begin
            inc(PicIndex);
            inc(InfoIndex);
            inc(Resolved);
          end;
        end;
      end;{ of case}
    end;{ of if }
    VariableResolution := Result;
  end;{ of function VariableResolution }

  function DefaultResolution: Boolean;
  var
    Result: Boolean;
  begin
    Result := true;
    if (PicIndex < StrLen(Pic)) and (InfoIndex < StrLen(Info)) then
    begin
      if (Info[InfoIndex] = ' ') and
        not(Pic[PicIndex] in (FormatSet - [';'] )) then
      begin
        if Pic[PicIndex] = ';' then
          inc(PicIndex);
        Info[InfoIndex] := Pic[PicIndex];
        inc(InfoIndex);
        inc(PicIndex);
        inc(Resolved);
      end;
    end;
    DefaultResolution := Result;
  end;

  function ConstantResolution: Boolean;
  var
    Result: Boolean;
  begin
    Result := true;
    if (InfoIndex = StrLen(Info)) then
    begin
      while (PicIndex < StrLen(Pic)) and
        not(Pic[PicIndex] in (FormatSet - [';'] + [','])) do
      begin
        if Pic[PicIndex] = ';' then
          inc(PicIndex);
        Info[StrLen(Info) + 1] := #0;
        Info[StrLen(Info)] := Pic[PicIndex];
        inc(InfoIndex);
        inc(Resolved);
        inc(PicIndex);
        CPos := InfoIndex - 1;
      end;
    end;
    ConstantResolution := Result;
  end;

  function NextItem(Pic: PChar; PicIndex: Integer;
    Terminator: Char): Integer;
  var
    GCount, OCount: Word;
    NewIndex: Integer;
  begin
    GCount := 0;
    OCount := 0;
    NewIndex := PicIndex;
    if Pic[NewIndex] <> Terminator then
    repeat
      case Pic[NewIndex] of
      '{': inc(GCount);
      '[': inc(OCount);
      ';': inc(NewIndex);
      '}': if GCount>0 then dec(GCount);
      ']': if OCount>0 then dec(OCount);
      end;
      inc(NewIndex);
    until ((GCount = 0) and (OCount = 0) and
      (Pic[NewIndex] = Terminator)) or (NewIndex = StrLen(Pic));
    NextItem := NewIndex;
  end;

  function DetermineCommitment: Boolean;
  var
    TempIndex: Integer;
  begin
    if Result and MayCommit then
    begin
      MayCommit := false;
      Committed := true;
      TempIndex := NextItem(Pic, PicIndex, ',');
      if (TempIndex < StrLen(Pic)) then
        Pic[TempIndex-1] := #0;
    end;
    if not Result and not Committed then
    begin
      TempIndex := NextItem(Pic, PicIndex, ',');
      if TempIndex < StrLen(Pic) then
      begin
        PicIndex := TempIndex + 1;
        InfoIndex := 0;
        Resolved := 0;
        Result := true;
      end;
    end;
    DetermineCommitment := Result;
  end;

  function CanBeBlank(Pic: PChar; PicIndex: Integer): Boolean;
  var
    NewIndex: Integer;
    TempPic: PChar;
    Result: Boolean;
  begin
    GetMem(TempPic, StrLen(Pic) + 1);
    Result := true;
    while (PicIndex < StrLen(Pic)) and (Pic[PicIndex] <>',') and
      Result do
    begin
      case Pic[PicIndex] of
        '{':
        begin
          NewIndex := NextItem(Pic, PicIndex, '}');
          StrCopy(TempPic, Pic);
          TempPic[NewIndex] := #0;
          TempPic := @TempPic[PicIndex + 1];
          Result := CanBeBlank(TempPic, 1);
          PicIndex := NewIndex + 1;
        end;

        '[':
        begin
          NewIndex := NextItem(Pic, PicIndex, ']');
          Result := true;
          PicIndex := NewIndex + 1;
        end;

        '*':
        begin
          if Pic[PicIndex + 1] in ['0'..'9'] then
          begin
            Result := true;
            inc(PicIndex);
            if Pic[PicIndex]='{' then
            begin
              PicIndex := NextItem(Pic, PicIndex, '}');
              inc(PicIndex);
            end
            else inc(PicIndex);
          end
          else Result := false;
        end
        else Result := false;
      end;
    end;
    CanBeBlank := Result;
    FreeMem(TempPic, StrLen(Pic) + 1);
  end;

  function CouldBeDone(Pic: PChar; PicIndex: Integer): Boolean;
  var
    TopPic, TempPic: PChar;
  begin
    GetMem(TempPic, StrLen(Pic) + 1);
    TopPic := TempPic;
    TempPic := @Pic[PicIndex];
    CouldBeDone := CanBeBlank(TempPic, 1);
    FreeMem(TopPic, StrLen(Pic) + 1);
  end;

  function DetermineResult(CalcResult: Boolean): Integer;
  var
    Result: Integer;
  begin
    if CalcResult then
      if CouldBeDone(Pic, PicIndex) then
        if (InfoIndex = StrLen(Info)) then Result := flFormatOk
        else Result := flPicOverflow
      else Result := flCharOk
    else Result := flError;
    if (Result = flError) or (Result = flPicOverflow) then
      CPos := InfoIndex;
    DetermineResult := Result;
  end;

begin
  PicIndex := 0;
  InfoIndex := 0;
  MayCommit := true;
  Committed := false;
  repeat
    DefaultResolution;  {Phase 2 Constant Resolution}
    Result := VariableResolution;
    if Result then
      Result := ConstantResolution;  {Phase 1 Constant Resolution}
    Result := DetermineCommitment;
  until not Result  or (InfoIndex >= StrLen(Info)) or
    (PicIndex >= StrLen(Pic));
  CheckPicture := DetermineResult(Result);
end;

procedure TFormEdit.WMChar(var Message: TMessage);
var
 FirstText, SecondText,  TopText, NextText: PChar;
 Result, CPos, Resolved, Dummy: Integer;
begin
  if (Message.WParam >31) and (Message.WParam < 127) then
  begin
    GetMem(FirstText, 255);
    GetMem(TopText, 255);
    GetMem(SecondText, 255);
    NextText := TopText;
    GetText(FirstText, 255);
    DefWndProc(Message);
    GetText(NextText, 255);
    StrCopy(SecondText, NextText);
    GetSelection(CPos, Dummy);
    Resolved:=0;
    Result := CheckPicture(NextText, Picture, CPos, Resolved);
    if (Result = flError) or (Result = flPicOverflow) then
    begin
      SetText(FirstText);
      SetSelection(CPos, CPos);
      MessageBeep(0);
    end
    else
    begin
      if StrComp(SecondText, NextText) <> 0 then
      begin
        SetText(NextText);
        SetSelection(CPos + 1, CPos + 1);
      end;
    end;
    FreeMem(FirstText, 255);
    FreeMem(TopText, 255);
    FreeMem(SecondText, 255);
  end
  else DefWndProc(Message);
end;

end.